home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / mkmsgsrc.zip / MKWCRT.PAS < prev    next >
Pascal/Delphi Source File  |  1992-09-19  |  19KB  |  821 lines
  1. Unit MKWCrt;
  2. {$R Keys.Res}
  3.  
  4. Interface
  5.  
  6. Uses WinProcs, WinTypes, WinDos;
  7.  
  8. Const
  9.   Black = 0;
  10.   Blue = 1;
  11.   Green = 2;
  12.   Cyan = 3;
  13.   Red = 4;
  14.   Magenta = 5;
  15.   Brown = 6;
  16.   LightGray = 7;
  17.   DarkGray = 8;
  18.   LightBlue = 9;
  19.   LightGreen = 10;
  20.   LightCyan = 11;
  21.   LightRed = 12;
  22.   LightMagenta = 13;
  23.   Yellow = 14;
  24.   White = 15;
  25.   Blink = 128;
  26.  
  27.  
  28. Const
  29.   TextAttr: Byte = $07;
  30.   TextChar: Char = ' ';
  31.   CheckBreak: Boolean = True;
  32.   CheckEOF: Boolean = False;
  33.   CheckSnow: Boolean = False;
  34.   DirectVideo: Boolean = False;
  35.   LastMode: Word = 3;
  36.   WindMin: Word = $0;
  37.   WindMax: Word = $184f;
  38.   ScreenWidth = 80;
  39.   ScreenHeight = 25;
  40.   KeyBufferSize = 20;
  41.  
  42. Const
  43.   AppName = 'AppName Here';
  44.  
  45. Procedure AssignWinCrt(Var F: Text);
  46. Procedure Delay(DTime: LongInt);
  47. Procedure TextColor(CL: Byte);
  48. Procedure TextBackground(CL: Byte);
  49. Procedure PutStr(Str: String);
  50. Procedure PutChar(Ch: Char);
  51. Procedure GoToXy(X: Byte; Y: Byte);
  52. Function  WhereX: Byte;
  53. Function  WhereY: Byte;
  54. Procedure Window(X1, Y1, X2, Y2: Byte);
  55. Procedure ClrScr;
  56. Procedure ClrEol;
  57. Function  KeyPressed: Boolean;
  58. Function  ReadKey: Char;
  59. Function  SaveScrnRegion(xl,yl,xh,yh: Byte; Var Pt: Pointer):Boolean;
  60. Procedure RestoreScrnRegion(xl,yl,xh,yh: Byte; Pt: Pointer);
  61. Procedure ScrollScrnRegionUp(xl,yl,xh,yh, count: Byte);
  62. Procedure ScrollScrnRegionDown(xl,yl,xh,yh, count: Byte);
  63. Procedure PutScrnWord (SX: Byte; SY: Byte; CA: Word);
  64. Function  GetScrnWord(SX: Byte; SY: Byte): Word;
  65. Procedure DelCharInLine(Sx: Byte; Sy: Byte);
  66. Procedure InsCharInLine(Sx: Byte; Sy: Byte; Ch: Char);
  67. Procedure InitializeScrnRegion(xl,yl,xh,yh: Byte; Ch: Char);
  68. Function  WindowProc(HWindow: HWnd; Message, WParam: Word;
  69.   LParam: Longint): Longint; export;
  70. Procedure RedrawScrn;
  71.  
  72.  
  73. Type ScrnArrayType = Array[0..(ScreenWidth * ScreenHeight)] of Word;
  74.  
  75. Type WordArray = Array[0..9999] of Word;
  76.  
  77. Type WordArrayPtr = ^WordArray;
  78.  
  79.  
  80. Var
  81.   HWindow: HWnd;
  82.   Accels: THandle;
  83.   Message: TMsg;
  84.   TVert: Word;
  85.   THorz: Word;
  86.   ScrnArray: ^ScrnArrayType;
  87.   KeyBuffer: Array[1..KeyBufferSize] of Char;
  88.   KeyPut: Byte;
  89.   KeySend: Byte;
  90.  
  91.  
  92.  
  93. Const
  94.   WindowClass: TWndClass = (
  95.     style: 0;
  96.     lpfnWndProc: @WindowProc;
  97.     cbClsExtra: 0;
  98.     cbWndExtra: 0;
  99.     hInstance: 0;
  100.     hIcon: 0;
  101.     hCursor: 0;
  102.     hbrBackground: 0;
  103.     lpszMenuName: AppName;
  104.     lpszClassName: AppName);
  105.  
  106.  
  107. Const
  108.   CurrX: Byte = 1;
  109.   CurrY: Byte = 1;
  110.  
  111. Implementation
  112.  
  113.  
  114. Const ColorArray: Array[0..15] of LongInt = (0, 1141120, 43520, 11184640,
  115.   170, 11141290, 43690, 11184810, 5592405, 16733525, 5635925,
  116.   16777045, 5592575, 16733695, 5636095, 16777215);
  117.  
  118. Procedure Delay(DTime: LongInt);
  119.   Const
  120.     TimerId = 1989;
  121.   Var
  122.     DDone: Boolean;
  123.  
  124.   Begin
  125.   DDone := False;
  126.   If SetTimer(HWindow,TimerId, DTime, nil) <> 0 Then
  127.     Begin
  128.     While Not DDone Do
  129.       Begin
  130.       WaitMessage;
  131.       If PeekMessage(Message, HWindow, 0, 0, pm_Remove) Then
  132.         Begin
  133.         If Message.Message = wm_Timer Then
  134.           DDone := True
  135.         Else
  136.           If (TranslateAccelerator(HWindow, Accels, Message) = 0) Then
  137.             Begin
  138.             TranslateMessage(Message);
  139.             DispatchMessage(Message);
  140.             End;
  141.         End;
  142.       End;
  143.     KillTimer(HWindow, TimerId);
  144.     End;
  145.   End;
  146.  
  147. Procedure TextColor(CL: Byte);
  148.   Begin
  149.   TextAttr := TextAttr and $F0;
  150.   TextAttr := TextAttr or (CL and $0F);
  151.   End;
  152.  
  153.  
  154. Procedure TextBackground(CL: Byte);
  155.   Begin
  156.   TextAttr := TextAttr and $0F;
  157.   TextAttr := TextAttr or (CL shl 4);
  158.   End;
  159.  
  160.  
  161. Procedure GoToXy(X: Byte; Y: Byte);
  162.   Begin
  163.   CurrX := X + (WindMin and $ff);
  164.   CurrY := Y + (WindMin shr 8);
  165.   If (CurrX > ((WindMax and $ff) + 1)) Then
  166.     CurrX := (WindMax and $ff) + 1;
  167.   If (CurrY > ((WindMax shr 8) + 1)) Then
  168.     CurrY := (WindMax shr 8) + 1;
  169.   End;
  170.  
  171.  
  172. Procedure Window(X1, Y1, X2, Y2: Byte);
  173.   Begin
  174.   WindMin := (Y1 - 1);
  175.   WindMin := (WindMin Shl 8) + (X1 - 1);
  176.   WindMax := (Y2 - 1);
  177.   WindMax := (WindMax Shl 8) + (X2 - 1);
  178.   End;
  179.  
  180.  
  181. Procedure ClrScr;
  182.   Var
  183.     CX, CY: Byte;
  184.     TmpStr: String;
  185.     NumRows, NumCols: Byte;
  186.     DC: HDC;
  187.     Metrics: TTextMetric;
  188.  
  189.   Begin
  190.   DC := GetDC(HWindow);
  191.   SetTextColor(DC,ColorArray[TextAttr and $0f]);
  192.   SetBkColor(DC, ColorArray[TextAttr shr 4]);
  193.   SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  194.   TmpStr := '';
  195.   Cx := (WindMin and $ff);
  196.   While (Cx <= (WindMax and $ff)) Do
  197.     Begin
  198.     TmpStr := TmpStr + TextChar;
  199.     Inc(Cx);
  200.     End;
  201.   Cy := (WindMin shr 8) + 1;
  202.   While (Cy <= ((WindMax shr 8) + 1)) Do
  203.     Begin
  204.     Cx := WindMin and $ff;
  205.     While Cx <= (WindMax and $ff) Do
  206.       Begin
  207.       ScrnArray^[(Cy - 1) * ScreenWidth + (Cx)] := Ord(TextChar) + (TextAttr shl 8);
  208.       Inc(Cx);
  209.       End;
  210.     TextOut(DC, (WindMin and $ff) * THorz, (CY - 1) * TVert, PChar(@TmpStr[1]),
  211.       Length(TmpStr));
  212.     Inc(Cy);
  213.     End;
  214.   TextChar := ' ';
  215.   ReleaseDC(HWindow,DC);
  216.   GoToXY(1, 1);
  217.   End;
  218.  
  219.  
  220. Procedure ClrEol;
  221.   Var
  222.     CX: Byte;
  223.     TmpStr: String;
  224.     DC: HDC;
  225.     Metrics: TTextMetric;
  226.  
  227.   Begin
  228.   DC := GetDC(HWindow);
  229.   SetTextColor(DC,ColorArray[TextAttr and $0f]);
  230.   SetBkColor(DC, ColorArray[TextAttr shr 4]);
  231.   SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  232.   CX := CurrX;
  233.   TmpStr := '';
  234.   While (CX <= ((WindMax and $ff)+ 1)) Do
  235.     Begin
  236.     TmpStr := TmpStr + TextChar;
  237.     Inc(Cx);
  238.     End;
  239.   TextOut(DC, (CurrX - 1) * THorz, (CurrY - 1) * TVert, PChar(@TmpStr[1]),
  240.     Length(TmpStr));
  241.   ReleaseDC(HWindow,DC);
  242.   End;
  243.  
  244.  
  245. Function WhereX: Byte;
  246.   Begin
  247.   WhereX := CurrX - (WindMin and $ff);
  248.   End;
  249.  
  250.  
  251. Function WhereY: Byte;
  252.   Begin
  253.   WhereY := CurrY - (WindMin shr 8);
  254.   End;
  255.  
  256.  
  257. Function GetKeyChar: Char;
  258.   Begin
  259.   If KeyPut <> KeySend Then
  260.     Begin
  261.     GetKeyChar := KeyBuffer[KeySend];
  262.     Inc(KeySend);
  263.     If KeySend > KeyBufferSize Then
  264.       KeySend := 1;
  265.     End
  266.   Else
  267.     GetKeyChar := #0;
  268.   End;
  269.  
  270.  
  271. Procedure PutKeyChar(Ch: Char);
  272.   Var
  273.     Tmp: Byte;
  274.  
  275.   Begin
  276.   Tmp := KeyPut;
  277.   Inc(KeyPut);
  278.   If KeyPut > KeyBufferSize Then
  279.     KeyPut := 1;
  280.   If KeyPut <> KeySend Then
  281.     KeyBuffer[Tmp] := Ch
  282.   Else
  283.     KeyPut := Tmp;
  284.   End;
  285.  
  286.  
  287. Procedure CharMsg(Message: TMsg);
  288.   Var
  289.     Tmp: Byte;
  290.  
  291.   Begin
  292.   PutKeyChar(Char(Message.wParam));
  293.   End;
  294.  
  295.  
  296. Function WindowProc(HWindow: HWnd; Message, WParam: Word;
  297.   LParam: Longint): Longint;
  298.   Var
  299.     PassOn: Boolean;
  300.  
  301.   Begin
  302.   PassOn := True;
  303.   WindowProc := 0;
  304.   case Message of
  305.     wm_Char:
  306.       Begin
  307.       If (LParam and 256) <> 0 Then
  308.         Begin
  309.         PutKeyChar(#0);
  310.         PutKeyChar(Chr(LParam and 127));
  311.         End
  312.       Else
  313.         PutKeyChar(Chr(WParam));
  314.       PassOn := False;
  315.       End;
  316.     wm_Command:
  317.       Begin
  318.       PutKeyChar(#0);
  319.       PutKeyChar(Chr(Lo(WParam)));
  320.       PassOn := False;
  321.       End;
  322.     wm_Destroy:
  323.       Begin
  324.       PostQuitMessage(0);
  325.       Exit;
  326.       End;
  327.     wm_Paint: RedrawScrn;
  328.     End;
  329.   If PassOn Then
  330.     WindowProc := DefWindowProc(HWindow, Message, WParam, LParam)
  331.   Else
  332.     WindowProc := 1;
  333.   End;
  334.  
  335.  
  336. Procedure PutChar(Ch: Char);
  337.   Var
  338.     DC: HDC;
  339.  
  340.   Begin
  341.   Case Ch of
  342.     #07: ;
  343.     #08: If CurrX > ((WindMin and $ff) + 1) Then
  344.           Dec(CurrX);
  345.     #10: Begin
  346.          Inc(CurrY);
  347.          If CurrY > ((WindMax shr 8) + 1) Then
  348.            Begin
  349.            CurrY := ((WindMax shr 8) + 1);
  350.            ScrollScrnRegionUp(1, 1, ScreenWidth, ScreenHeight,1);
  351.            End;
  352.          End;
  353.     #13: CurrX := 1;
  354.     Else
  355.       Begin
  356.       DC := GetDC(HWindow);
  357.       SetTextColor(DC,ColorArray[TextAttr and $0f]);
  358.       SetBkColor(DC, ColorArray[TextAttr shr 4]);
  359.       SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  360.       ScrnArray^[(CurrX - 1) + (CurrY - 1) * ScreenWidth] := Ord(ch) + (TextAttr shl 8);
  361.       TextOut(DC, (CurrX - 1) * THorz, (CurrY - 1) * TVert, PChar(@Ch), 1);
  362.       ReleaseDC(HWindow,DC);
  363.       Inc(CurrX);
  364.       If CurrX > ((WindMax and $FF) + 1) Then
  365.         Begin
  366.         CurrX := (WindMin and $FF) + 1;
  367.         Inc(CurrY);
  368.          If CurrY >= ((WindMax shr 8) + 1) Then
  369.            Begin
  370.            CurrY := (WindMax shr 8) + 1;
  371.            ScrollScrnRegionUp(1, 1, ScreenWidth, ScreenHeight, 1);
  372.            End;
  373.         End;
  374.       End;
  375.     End;
  376.   End;
  377.  
  378.  
  379. Procedure PutStr(Str: String);
  380.   Var
  381.     i: Word;
  382.  
  383.   Begin
  384.   i := 1;
  385.   While i <= Length(Str) Do
  386.     Begin
  387.     PutChar(Str[i]);
  388.     Inc(i);
  389.     End;
  390.   End;
  391.  
  392.  
  393. Procedure ScrollScrnRegionUp(xl,yl,xh,yh, count: Byte);
  394.   Var
  395.     Ty: Byte;
  396.     Tx: Byte;
  397.     Wdth: Byte;
  398.     DC: HDC;
  399.     Rect: TRect;
  400.     TempStr: String;
  401.  
  402.  
  403.   Begin
  404.   xl := xl + (WindMin and $ff);
  405.   yl := yl + (WindMin shr 8);
  406.   xh := xh + (WindMin and $ff);
  407.   yh := yh + (WindMin shr 8);
  408.   If yh > ((WindMax shr 8) + 1) Then
  409.     yh := ((WindMax shr 8) + 1);
  410.   If xh > ((WindMax and $ff) + 1) Then
  411.     xh := ((WindMax and $ff) + 1);
  412.   Wdth := Xh + 1 - Xl;
  413.   If Wdth > 0 Then
  414.     Begin
  415.     Ty := yl;
  416.     While Ty < yh Do
  417.       Begin
  418.       Move(ScrnArray^[(Ty * ScreenWidth) + XL - 1],
  419.         ScrnArray^[((Ty - 1) * ScreenWidth) + XL - 1], Wdth);
  420.       Inc(Ty);
  421.       End;
  422.     For Tx := xl to xh Do
  423.       ScrnArray^[(Tx - 1) + (yh - 1) * ScreenWidth] :=  32 + (TextAttr shl 8);
  424.     Rect.Left := (xl - 1) * THorz;
  425.     Rect.Right := (xh) * THorz;
  426.     Rect.Top := (yl - 1) * TVert;
  427.     Rect.Bottom := (yh) * TVert;
  428.     ScrollWindow(HWindow, 0,  -TVert * Count, @Rect, @Rect);
  429.     DC := GetDC(HWindow);
  430.     SetTextColor(DC,ColorArray[TextAttr and $0f]);
  431.     SetBkColor(DC, ColorArray[TextAttr shr 4]);
  432.     SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  433.     TempStr := '';
  434.     For tx := xl to xh Do
  435.       TempStr := TempStr + ' ';
  436.     TextOut(DC, (Xl - 1) * THorz, (Yh - 1) * TVert, PChar(@TempStr[1]),
  437.       Length(TempStr));
  438.     ReleaseDC(HWindow,DC);
  439.     End;
  440.   End;
  441.  
  442.  
  443. Procedure ScrollScrnRegionDown(xl,yl,xh,yh, count: Byte);
  444.   Var
  445.     Ty: Byte;
  446.     Tx: Byte;
  447.     Wdth: Byte;
  448.     DC: HDC;
  449.     Rect: TRect;
  450.     TempStr: String;
  451.  
  452.   Begin
  453.   xl := xl + (WindMin and $ff);
  454.   yl := yl + (WindMin shr 8);
  455.   xh := xh + (WindMin and $ff);
  456.   yh := yh + (WindMin shr 8);
  457.   If yh > ((WindMax shr 8) + 1) Then
  458.     yh := ((WindMax shr 8) + 1);
  459.   If xh > ((WindMax and $ff) + 1) Then
  460.     xh := ((WindMax and $ff) + 1);
  461.   Wdth := Xh + 1 - Xl;
  462.   If Wdth > 0 Then
  463.     Begin
  464.     Ty := yh;
  465.     While Ty > yl Do
  466.       Begin
  467.       Move(ScrnArray^[((Ty - 2) * ScreenWidth) + XL - 1],
  468.         ScrnArray^[((Ty - 1) * ScreenWidth) + XL - 1], Wdth);
  469.       Dec(Ty);
  470.       End;
  471.     For Tx := xl to xh Do
  472.       ScrnArray^[(Tx - 1) + (yl - 1) * ScreenWidth] :=  32 + (TextAttr shl 8);
  473.     Rect.Left := (xl - 1) * THorz;
  474.     Rect.Right := (xh) * THorz;
  475.     Rect.Top := (yl - 1) * TVert;
  476.     Rect.Bottom := (yh) * TVert;
  477.     ScrollWindow(HWindow, 0, Count * TVert, @Rect, @Rect);
  478.     DC := GetDC(HWindow);
  479.     SetTextColor(DC,ColorArray[TextAttr and $0f]);
  480.     SetBkColor(DC, ColorArray[TextAttr shr 4]);
  481.     SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  482.     TempStr := '';
  483.     For tx := xl to xh Do
  484.       TempStr := TempStr + ' ';
  485.     TextOut(DC, (Xl - 1) * THorz, (Yl - 1) * TVert, PChar(@TempStr[1]),
  486.       Length(TempStr));
  487.     ReleaseDC(HWindow,DC);
  488.     End;
  489.   End;
  490.  
  491.  
  492. Procedure PutScrnWordDC(SX: Byte; SY: Byte; CA: Word; Var DC: HDC);
  493.   Var
  494.     Attr: Byte;
  495.     Ch: Char;
  496.  
  497.   Begin
  498.   ScrnArray^[((SY - 1) * ScreenWidth) + SX - 1] := CA;
  499.   Ch := Chr(Lo(CA));
  500.   Attr := CA shr 8;
  501.   SetTextColor(DC,ColorArray[Attr and $0f]);
  502.   SetBkColor(DC, ColorArray[Attr shr 4]);
  503.   SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  504.   TextOut(DC, (SX - 1) * THorz, (SY - 1) * TVert, PChar(@Ch), 1);
  505.   End;
  506.  
  507.  
  508. Procedure RedrawScrn;
  509.   Var
  510.     DC: HDC;
  511.     Paint: TPaintStruct;
  512.     Tx, Ty: Word;
  513.     Mx, My: Word;
  514.     Attr: Byte;
  515.     LA: Byte;
  516.     Ch: Char;
  517.  
  518.   Begin
  519.   If ((THorz > 0) and (TVert > 0)) Then
  520.     Begin
  521.     DC := BeginPaint(HWindow, Paint);
  522.     Tx := Paint.RcPaint.Left div THorz;
  523.     Ty := Paint.RcPaint.Top div TVert;
  524.     If ((Tx < (ScreenWidth - 1)) and (Ty < (ScreenHeight - 1))) Then
  525.       Begin
  526.       Mx := (Paint.RcPaint.Right div Thorz) + 1;
  527.       My := (Paint.RcPaint.Bottom div TVert) + 1;
  528.       If Mx > (ScreenWidth - 1) Then
  529.         Mx := ScreenWidth - 1;
  530.       If My > (ScreenHeight - 1) Then
  531.         My := ScreenHeight - 1;
  532.       Attr := ScrnArray^[Tx + (ScreenWidth * Ty)] Shr  8;
  533.       LA := Attr;
  534.       SetTextColor(DC,ColorArray[Attr and $0f]);
  535.       SetBkColor(DC, ColorArray[Attr shr 4]);
  536.       SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  537.       While Ty <= My Do
  538.         Begin
  539.         Tx := Paint.RcPaint.Left div THorz;
  540.         While Tx <= Mx Do
  541.           Begin
  542.           Attr := ScrnArray^[Tx + (TY * ScreenWidth)] shr 8;
  543.           If Attr <> LA Then
  544.             Begin
  545.             SetTextColor(DC,ColorArray[Attr and $0f]);
  546.             SetBkColor(DC, ColorArray[Attr shr 4]);
  547.             LA := Attr;
  548.             End;
  549.           Ch := Chr(ScrnArray^[Tx + (TY * ScreenWidth)] and $ff);
  550.           TextOut(DC, Tx * THorz, TY * TVert, PChar(@Ch), 1);
  551.           Inc(Tx);
  552.           End;
  553.         Inc(Ty);
  554.         End;
  555.       End;
  556.     EndPaint(HWindow, Paint);
  557.     End;
  558.   End;
  559.  
  560.  
  561. Procedure PutScrnWord (SX: Byte; SY: Byte; CA: Word);
  562.   Var
  563.     DC: HDC;
  564.  
  565.   Begin
  566.   DC := GetDC(HWindow);
  567.   PutScrnWordDC(SX, SY, CA, DC);
  568.   ReleaseDC(HWindow,DC);
  569.   End;
  570.  
  571.  
  572. Function  GetScrnWord(SX: Byte; SY: Byte): Word;
  573.   Begin
  574.   GetScrnWord := ScrnArray^[((SY - 1) * ScreenWidth) + SX - 1];
  575.   End;
  576.  
  577.  
  578. Function SaveScrnRegion(xl,yl,xh,yh: Byte; Var Pt: Pointer):Boolean;
  579.   Var
  580.     Tx: Byte;
  581.     Ty: Byte;
  582.     Ctr: Word;
  583.  
  584.   Begin
  585.   GetMem(Pt, ((xh + 1 - xl) * (yh +1 - yl) * 2));
  586.   If Pt = nil Then
  587.     SaveScrnRegion := False
  588.   Else
  589.     Begin
  590.     SaveScrnRegion := True;
  591.     Ctr := 0;
  592.     For Tx := xl to xh Do
  593.       Begin
  594.       For Ty := yl to yh Do
  595.         Begin
  596.         WordArrayPtr(PT)^[Ctr] := GetScrnWord(Tx, Ty);
  597.         Inc(Ctr);
  598.         End;
  599.       End;
  600.     End;
  601.   End;
  602.  
  603.  
  604. Procedure RestoreScrnRegion(xl,yl,xh,yh: Byte; Pt: Pointer);
  605.   Var
  606.     Tx: Byte;
  607.     Ty: Byte;
  608.     Ctr: Word;
  609.  
  610.   Begin
  611.   If Pt <> nil Then
  612.     Begin
  613.     Ctr := 0;
  614.     For Tx := xl to xh Do
  615.       Begin
  616.       For Ty := yl to yh Do
  617.         Begin
  618.         PutScrnWord(Tx, Ty, WordArrayPtr(PT)^[Ctr]);
  619.         Inc(Ctr);
  620.         End;
  621.       End;
  622.     FreeMem(Pt, ((xh + 1 - xl) * (yh +1 - yl) * 2));
  623.     End;
  624.   End;
  625.  
  626.  
  627.  
  628. Procedure DelCharInLine(Sx: Byte; Sy: Byte);
  629.   Var
  630.     Ex: Byte;
  631.     Cx: Byte;
  632.  
  633.   Begin
  634.   Ex := Lo(WindMax) + 1;
  635.   Cx := Sx;
  636.   While (Cx < Ex) Do
  637.     Begin
  638.     PutScrnWord(Cx, Sy, GetScrnWord(Cx + 1, Sy));
  639.     Inc(Cx);
  640.     End;
  641.   PutScrnWord(Ex, Sy, 32 + (TextAttr shl 8));
  642.   End;
  643.  
  644.  
  645. Procedure InsCharInLine(Sx: Byte; Sy: Byte; Ch: Char);
  646.   Var
  647.     Ex: Byte;
  648.     Cx: Byte;
  649.  
  650.   Begin
  651.   Ex := Lo(WindMax) + 1;
  652.   Cx := Ex;
  653.   While (Cx > Sx) Do
  654.     Begin
  655.     PutScrnWord(Cx, Sy, GetScrnWord(Cx - 1, Sy));
  656.     Dec(Cx);
  657.     End;
  658.   PutScrnWord(Sx, Sy, Ord(Ch) + (TextAttr shl 8));
  659.   End;
  660.  
  661.  
  662. Procedure InitializeScrnRegion(xl,yl,xh,yh: Byte; Ch: Char);
  663.   Var
  664.     Cx, Cy: Byte;
  665.  
  666.   Begin
  667.   xl := xl + (WindMin and $ff);
  668.   yl := yl + (WindMin shr 8);
  669.   xh := xh + (WindMin and $ff);
  670.   yh := yh + (WindMin shr 8);
  671.   If yh > ((WindMax shr 8) + 1) Then
  672.     yh := ((WindMax shr 8) + 1);
  673.   If xh > ((WindMax and $ff) + 1) Then
  674.     xh := ((WindMax and $ff) + 1);
  675.   Cx := xl;
  676.   Cy := yl;
  677.   While (cy <= yh) Do
  678.     Begin
  679.     While (Cx <= xh) Do
  680.       Begin
  681.       PutScrnWord(Cx, Cy, Ord(ch) + (TextAttr shl 8));
  682.       Inc(Cx);
  683.       End;
  684.     Inc(Cy);
  685.     End;
  686.   End;
  687.  
  688.  
  689.  
  690. Function  KeyPressed: Boolean;
  691.   Begin
  692.   If PeekMessage(Message, HWindow, wm_KeyFirst, wm_KeyLast, pm_NoRemove) Then
  693.     Begin
  694.     GetMessage(Message, HWindow, wm_KeyFirst, wm_KeyLast);
  695.     If (TranslateAccelerator(HWindow, Accels, Message) = 0) Then
  696.       Begin
  697.       TranslateMessage(Message);
  698.       DispatchMessage(Message);
  699.       End;
  700.     End;
  701.   KeyPressed := (KeyPut <> KeySend);
  702.   End;
  703.  
  704.  
  705. Function  ReadKey: Char;
  706.   Begin
  707.   While KeySend = KeyPut Do
  708.     Begin
  709.     While PeekMessage(Message, HWindow, 0, 0, pm_NoRemove) Do
  710.       Begin
  711.       GetMessage(Message, HWindow, 0, 0);
  712.       If (TranslateAccelerator(HWindow, Accels, Message) = 0) Then
  713.         Begin
  714.         TranslateMessage(Message);
  715.         DispatchMessage(Message);
  716.         End;
  717.       End;
  718.     End;
  719.   ReadKey := GetKeyChar;
  720.   End;
  721.  
  722.  
  723. Procedure WinMain;
  724.   Var
  725.     DC: HDC;
  726.     Metrics: TTextMetric;
  727.  
  728.   Begin
  729.   if HPrevInst = 0 then
  730.     Begin
  731.     WindowClass.hInstance := HInstance;
  732.     WindowClass.hIcon := LoadIcon(0, idi_Application);
  733.     WindowClass.hCursor := LoadCursor(0, idc_Arrow);
  734.     WindowClass.hbrBackground := GetStockObject(white_Brush);
  735.     if not RegisterClass(WindowClass) then Halt(255);
  736.     End;
  737.   HWindow := CreateWindow(
  738.   AppName,
  739.     'MKWCrt Application',
  740.     ws_OverlappedWindow,
  741.     cw_UseDefault,
  742.     cw_UseDefault,
  743.     cw_UseDefault,
  744.     cw_UseDefault,
  745.     0,
  746.     0,
  747.     HInstance,
  748.     nil);
  749.   ShowWindow(HWindow, CmdShow);
  750.   UpdateWindow(HWindow);
  751.   DC := GetDC(HWindow);
  752.   SelectObject(DC, GetStockObject(OEM_Fixed_Font));
  753.   GetTextMetrics(DC, Metrics);
  754.   TVert := Metrics.tmHeight + Metrics.tmInternalLeading +
  755.     Metrics.tmExternalLeading;
  756.   THorz := Metrics.tmAveCharWidth;
  757.   ReleaseDC(HWindow,DC);
  758.   End;
  759.  
  760.  
  761. {$F+}
  762. Function WinWrite(Var F: TTextRec): Integer;
  763.   Var
  764.     i: Word;
  765.  
  766.   Begin
  767.   i := 0;
  768.   While i < F.BufPos Do
  769.     Begin
  770.     PutChar(F.BufPtr^[i]);
  771.     Inc(i);
  772.     End;
  773.   F.BufPos := 0;
  774.   WinWrite := 0;
  775.   End;
  776.  
  777.  
  778. {$F+}
  779. Function WinCrtClose(Var F: TTextRec): Integer;
  780.   Begin
  781.   F.Mode := fmClosed;
  782.   WinCrtClose := 0;
  783.   End;
  784.  
  785.  
  786. {$F+}
  787. Function WinCrtOpen(Var F: TTextRec): Integer;
  788.   Begin
  789.   If F.Mode = fmOutput Then
  790.     WinCrtOpen := 0
  791.   Else
  792.     WinCrtOpen := 5;
  793.   End;
  794.  
  795.  
  796. Procedure AssignWinCrt(Var F: Text);
  797.   Begin
  798.   TTextRec(F).Mode := fmClosed;
  799.   TTextRec(F).BufSize := SizeOf(TTextBuf);
  800.   TTextRec(F).BufPtr := @TTextRec(F).Buffer;
  801.   TTextRec(F).OpenFunc := @WinCrtOpen;
  802.   TTextRec(F).InOutFunc := @WinWrite;
  803.   TTextRec(F).FlushFunc := @WinWrite;
  804.   TTextRec(F).CloseFunc := @WinCrtClose;
  805.   TTextRec(F).Name[0] := #0;
  806.   End;
  807.  
  808.  
  809. Begin
  810. New(ScrnArray);
  811. WinMain;
  812. Accels :=LoadAccelerators(HInstance, 'A_RESOURCE');
  813. If Accels = 0 Then
  814.   MessageBeep(0);
  815. AssignWinCrt(Output);
  816. Rewrite(Output);
  817. KeyPut := 1;
  818. KeySend := 1;
  819. ClrScr;
  820. End.
  821.